home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlread.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  18KB  |  866 lines
  1. /* xlread - xlisp expression input routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* symbol parser modes */
  9. #define DONE    0
  10. #define NORMAL    1
  11. #define ESCAPE    2
  12.  
  13. /* external variables */
  14. extern LVAL s_stdout,true,s_dot;
  15. extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
  16. extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
  17. extern LVAL k_sescape,k_mescape;
  18. extern char buf[];
  19.  
  20. /* external routines */
  21. extern FILE *osaopen();
  22. extern double atof();
  23. extern ITYPE;
  24.  
  25. #define WSPACE "\t \f\r\n"
  26. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  27. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  28.  
  29. /* forward declarations */
  30. FORWARD LVAL callmacro();
  31. FORWARD LVAL psymbol(),punintern();
  32. FORWARD LVAL pnumber(),pquote(),plist(),pvector(),pstruct();
  33. FORWARD LVAL readlist(),tentry();
  34.  
  35. /* xlload - load a file of xlisp expressions */
  36. int xlload(fname,vflag,pflag)
  37.   char *fname; int vflag,pflag;
  38. {
  39.     char fullname[STRMAX+1];
  40.     LVAL fptr,expr;
  41.     CONTEXT cntxt;
  42.     FILE *fp;
  43.     int sts;
  44.  
  45.     /* protect some pointers */
  46.     xlstkcheck(2);
  47.     xlsave(fptr);
  48.     xlsave(expr);
  49.  
  50.     /* default the extension */
  51.     if (needsextension(fname)) {
  52.     strcpy(fullname,fname);
  53.     strcat(fullname,".lsp");
  54.     fname = fullname;
  55.     }
  56.  
  57.     /* allocate a file node */
  58.     fptr = cvfile(NULL);
  59.  
  60.     /* open the file */
  61.     if ((fp = osaopen(fname,"r")) == NULL) {
  62.     xlpopn(2);
  63.     return (FALSE);
  64.     }
  65.     setfile(fptr,fp);
  66.  
  67.     /* print the information line */
  68.     if (vflag)
  69.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  70.  
  71.     /* read, evaluate and possibly print each expression in the file */
  72.     xlbegin(&cntxt,CF_ERROR,true);
  73.     if (setjmp(cntxt.c_jmpbuf))
  74.     sts = FALSE;
  75.     else {
  76.     while (xlread(fptr,&expr,FALSE)) {
  77.         expr = xleval(expr);
  78.         if (pflag)
  79.         stdprint(expr);
  80.     }
  81.     sts = TRUE;
  82.     }
  83.     xlend(&cntxt);
  84.  
  85.     /* close the file */
  86.     osclose(getfile(fptr));
  87.     setfile(fptr,NULL);
  88.  
  89.     /* restore the stack */
  90.     xlpopn(2);
  91.  
  92.     /* return status */
  93.     return (sts);
  94. }
  95.  
  96. /* xlread - read an xlisp expression */
  97. int xlread(fptr,pval,rflag)
  98.   LVAL fptr,*pval; int rflag;
  99. {
  100.     int sts;
  101.  
  102.     /* read an expression */
  103.     while ((sts = readone(fptr,pval)) == FALSE)
  104.     ;
  105.  
  106.     /* return status */
  107.     return (sts == EOF ? FALSE : TRUE);
  108. }
  109.  
  110. /* readone - attempt to read a single expression */
  111. int readone(fptr,pval)
  112.   LVAL fptr,*pval;
  113. {
  114.     LVAL val,type;
  115.     int ch;
  116.  
  117.     /* get a character and check for EOF */
  118.     if ((ch = xlgetc(fptr)) == EOF)
  119.     return (EOF);
  120.  
  121.     /* handle white space */
  122.     if ((type = tentry(ch)) == k_wspace)
  123.     return (FALSE);
  124.  
  125.     /* handle symbol constituents */
  126.     else if (type == k_const) {
  127.     xlungetc(fptr,ch);
  128.     *pval = psymbol(fptr);
  129.     return (TRUE);        
  130.     }
  131.  
  132.     /* handle single and multiple escapes */
  133.     else if (type == k_sescape || type == k_mescape) {
  134.     xlungetc(fptr,ch);
  135.     *pval = psymbol(fptr);
  136.     return (TRUE);
  137.     }
  138.     
  139.     /* handle read macros */
  140.     else if (consp(type)) {
  141.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  142.         *pval = car(val);
  143.         return (TRUE);
  144.     }
  145.     else
  146.         return (FALSE);
  147.     }
  148.  
  149.     /* handle illegal characters */
  150.     else
  151.     xlerror("illegal character",cvfixnum((FIXTYPE)ch));
  152. }
  153.  
  154. /* rmhash - read macro for '#' */
  155. LVAL rmhash()
  156. {
  157.     LVAL fptr,mch,val;
  158.     int escflag,ch;
  159.  
  160.     /* protect some pointers */
  161.     xlsave1(val);
  162.  
  163.     /* get the file and macro character */
  164.     fptr = xlgetfile();
  165.     mch = xlgachar();
  166.     xllastarg();
  167.  
  168.     /* make the return value */
  169.     val = consa(NIL);
  170.  
  171.     /* check the next character */
  172.     switch (ch = xlgetc(fptr)) {
  173.     case '\'':
  174.         rplaca(val,pquote(fptr,s_function));
  175.         break;
  176.     case '(':
  177.         xlungetc(fptr,ch);
  178.         rplaca(val,pvector(fptr));
  179.         break;
  180.     case 'b':
  181.     case 'B':
  182.         rplaca(val,pnumber(fptr,2));
  183.         break;
  184.     case 'o':
  185.     case 'O':
  186.         rplaca(val,pnumber(fptr,8));
  187.         break;
  188.     case 'x':
  189.     case 'X':
  190.             rplaca(val,pnumber(fptr,16));
  191.         break;
  192.     case 's':
  193.     case 'S':
  194.         rplaca(val,pstruct(fptr));
  195.         break;
  196.     case '\\':
  197.         xlungetc(fptr,ch);
  198.         pname(fptr,&escflag);
  199.         ch = buf[0];
  200.         if (strlen(buf) > 1) {
  201.             upcase(buf);
  202.             if (strcmp(buf,"NEWLINE") == 0)
  203.             ch = '\n';
  204.             else if (strcmp(buf,"SPACE") == 0)
  205.             ch = ' ';
  206.             else
  207.             xlerror("unknown character name",cvstring(buf));
  208.         }
  209.         rplaca(val,cvchar(ch));
  210.         break;
  211.     case ':':
  212.             rplaca(val,punintern(fptr));
  213.         break;
  214.     case '|':
  215.             pcomment(fptr);
  216.         val = NIL;
  217.         break;
  218.     default:
  219.         xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
  220.     }
  221.  
  222.     /* restore the stack */
  223.     xlpop();
  224.  
  225.     /* return the value */
  226.     return (val);
  227. }
  228.  
  229. /* rmquote - read macro for '\'' */
  230. LVAL rmquote()
  231. {
  232.     LVAL fptr,mch;
  233.  
  234.     /* get the file and macro character */
  235.     fptr = xlgetfile();
  236.     mch = xlgachar();
  237.     xllastarg();
  238.  
  239.     /* parse the quoted expression */
  240.     return (consa(pquote(fptr,s_quote)));
  241. }
  242.  
  243. /* rmdquote - read macro for '"' */
  244. LVAL rmdquote()
  245. {
  246.     unsigned char buf[STRMAX+1],*p,*sptr;
  247.     LVAL fptr,str,newstr,mch;
  248.     int len,blen,ch,d2,d3;
  249.  
  250.     /* protect some pointers */
  251.     xlsave1(str);
  252.  
  253.     /* get the file and macro character */
  254.     fptr = xlgetfile();
  255.     mch = xlgachar();
  256.     xllastarg();
  257.  
  258.     /* loop looking for a closing quote */
  259.     len = blen = 0; p = buf;
  260.     while ((ch = checkeof(fptr)) != '"') {
  261.  
  262.     /* handle escaped characters */
  263.     switch (ch) {
  264.     case '\\':
  265.         switch (ch = checkeof(fptr)) {
  266.         case 't':
  267.             ch = '\011';
  268.             break;
  269.         case 'n':
  270.             ch = '\012';
  271.             break;
  272.         case 'f':
  273.             ch = '\014';
  274.             break;
  275.         case 'r':
  276.             ch = '\015';
  277.             break;
  278.         default:
  279.             if (ch >= '0' && ch <= '7') {
  280.                 d2 = checkeof(fptr);
  281.                 d3 = checkeof(fptr);
  282.                 if (d2 < '0' || d2 > '7'
  283.                  || d3 < '0' || d3 > '7')
  284.                 xlfail("invalid octal digit");
  285.                 ch -= '0'; d2 -= '0'; d3 -= '0';
  286.                 ch = (ch << 6) | (d2 << 3) | d3;
  287.             }
  288.             break;
  289.         }
  290.     }
  291.  
  292.     /* check for buffer overflow */
  293.     if (blen >= STRMAX) {
  294.          newstr = newstring(len + STRMAX + 1);
  295.         sptr = getstring(newstr); *sptr = '\0';
  296.         if (str) strcat(sptr,getstring(str));
  297.         *p = '\0'; strcat(sptr,buf);
  298.         p = buf; blen = 0;
  299.         len += STRMAX;
  300.         str = newstr;
  301.     }
  302.  
  303.     /* store the character */
  304.     *p++ = ch; ++blen;
  305.     }
  306.  
  307.     /* append the last substring */
  308.     if (str == NIL || blen) {
  309.     newstr = newstring(len + blen + 1);
  310.     sptr = getstring(newstr); *sptr = '\0';
  311.     if (str) strcat(sptr,getstring(str));
  312.     *p = '\0'; strcat(sptr,buf);
  313.     str = newstr;
  314.     }
  315.  
  316.     /* restore the stack */
  317.     xlpop();
  318.  
  319.     /* return the new string */
  320.     return (consa(str));
  321. }
  322.  
  323. /* rmbquote - read macro for '`' */
  324. LVAL rmbquote()
  325. {
  326.     LVAL fptr,mch;
  327.  
  328.     /* get the file and macro character */
  329.     fptr = xlgetfile();
  330.     mch = xlgachar();
  331.     xllastarg();
  332.  
  333.     /* parse the quoted expression */
  334.     return (consa(pquote(fptr,s_bquote)));
  335. }
  336.  
  337. /* rmcomma - read macro for ',' */
  338. LVAL rmcomma()
  339. {
  340.     LVAL fptr,mch,sym;
  341.     int ch;
  342.  
  343.     /* get the file and macro character */
  344.     fptr = xlgetfile();
  345.     mch = xlgachar();
  346.     xllastarg();
  347.  
  348.     /* check the next character */
  349.     if ((ch = xlgetc(fptr)) == '@')
  350.     sym = s_comat;
  351.     else {
  352.     xlungetc(fptr,ch);
  353.     sym = s_comma;
  354.     }
  355.  
  356.     /* make the return value */
  357.     return (consa(pquote(fptr,sym)));
  358. }
  359.  
  360. /* rmlpar - read macro for '(' */
  361. LVAL rmlpar()
  362. {
  363.     LVAL fptr,mch;
  364.  
  365.     /* get the file and macro character */
  366.     fptr = xlgetfile();
  367.     mch = xlgachar();
  368.     xllastarg();
  369.  
  370.     /* make the return value */
  371.     return (consa(plist(fptr)));
  372. }
  373.  
  374. /* rmrpar - read macro for ')' */
  375. LVAL rmrpar()
  376. {
  377.     xlfail("misplaced right paren");
  378. }
  379.  
  380. /* rmsemi - read macro for ';' */
  381. LVAL rmsemi()
  382. {
  383.     LVAL fptr,mch;
  384.     int ch;
  385.  
  386.     /* get the file and macro character */
  387.     fptr = xlgetfile();
  388.     mch = xlgachar();
  389.     xllastarg();
  390.  
  391.     /* skip to end of line */
  392.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  393.     ;
  394.  
  395.     /* return nil (nothing read) */
  396.     return (NIL);
  397. }
  398.  
  399. /* pcomment - parse a comment delimited by #| and |# */
  400. LOCAL pcomment(fptr)
  401.   LVAL fptr;
  402. {
  403.     int lastch,ch,n;
  404.  
  405.     /* look for the matching delimiter (and handle nesting) */
  406.     for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr))